##
## Admin functions / commands
package Purl::Commands::admin;
no define NONE =>;

use Purl::Config;

sub import {

    # Register the commands when they are loaded into the system
    Purl::Commands::register(
        name    => '@reload',
        authRef => \&Purl::tests::isWizard,
        subRef  => \&Purl::Commands::admin::cmd_reload,
    );
    Purl::Commands::register(
        name    => "\@shutdown",
        authRef => \&Purl::tests::isWizard,
        subRef  => \&Purl::Commands::admin::cmd_shutdown,
    );
    Purl::Commands::register(
        name    => "\@dump",
        authRef => \&Purl::tests::isWizard,
        subRef  => \&Purl::Commands::admin::dump,
    );

    #    Purl::Commands::register(
    #        name    => "\@purge",
    #        authRef => \&Purl::tests::isWizard,
    #        subRef  => \&Purl::Commands::admin::purge,
    #    );
    Purl::Commands::register(
        name    => "\@boot",
        authRef => \&Purl::tests::isWizard,
        subRef  => \&Purl::Commands::admin::boot,
    );
    Purl::Commands::register(
        name   => "\@config",
        subRef => \&Purl::Commands::admin::cmd_config,
    );
}

sub cmd_reload {
    my %args = @_;
    &dump(%args);
    $main::reloadFlag = 1;
}

sub cmd_shutdown {
    my %args = @_;
    $args{text} = "Shutdown! See ya later!" if ( !$args{text} );
    $main::server->broadcast( $main::server->{mux}, $args{text} );
    &dump(%args);

    $main::server->server_close;

}

sub restore {
    my ( $id, $dbVersion, $dbVersionKnown );
    if ( !CORE::open( IN, $dbFile ) ) {
        print "Unable to read from " . $dbFile . ".\n";
        print "Please read the documentation and follow\n";
        print "all of the instructions carefully.\n";
        exit 0;
    }
    $dbVersionKnown = 0;
    while ( $id = <IN> ) {
        if ( !$dbVersionKnown ) {
            $dbVersionKnown = 1;
            if ( !( $id =~ /^\d+\.\d+\s*$/ ) ) {
                $dbVersion = 0.0;
            }
            else {
                $dbVersion = $id;
                if ( $dbVersion > $Version ) {
                    print
                        "This database was written by a newer version of PurlMUSH!\nYou need version $dbVersion to read it.\n";
                    close(IN);
                    return 0;
                }
                next;
            }
        }
        chomp $id;
        while (1) {
            my ( $attribute, $value, $line );
            $line = <IN>;
            if ( $line eq "" ) {

                #Uh-oh
                print "Database is truncated!\n";
                return 0;
            }
            chomp $line;
            if ( $line eq "<END>" ) {
                last;
            }

            # Get the attribute and the value
            ( $attribute, $value ) = split( / /, $line, 2 );

            # Unescape endlines
            $value =~ s/\\n/\r\n/g;

            # But a slash preceding one of those
            # means an escaped LF is truly wanted
            $value =~ s/\\\r\n/\\n/g;
            $main::objects[$id]{$attribute} = $value;
        }
        $main::objects[$id]{"id"} = $id;
        if ( $id == 1 ) {
            $main::objects[1]{"flags"} |= $flags{"wizard"}{"value"};
        }
        if (   ( $main::objects[$id]{"type"} == $player )
            || ( $main::objects[$id]{"flags"} & $flags{"creature"}{"value"} )
            )
        {
            my $n = $main::objects[$id]{"name"};
            $n =~ tr/A-Z/a-z/;
            $main::playerIds{$n} = $id;
        }

        # GOTCHA: NONE and 0 are different
        $main::objects[$id]{"activeFd"} = NONE;
    }
    close(IN);
    return 1;
}

sub mindb {
    $main::objects[0]{"name"}     = "Void";
    $main::objects[0]{"type"}     = $room;
    $main::objects[0]{"contents"} = "1";
    $main::objects[0]{"owner"}    = 1;
    $main::objects[1]{"name"}     = "God";
    $main::objects[1]{"type"}     = $player;
    $main::objects[1]{"location"} = 0;
    $main::objects[1]{"owner"}    = 1;
    $main::objects[1]{"password"}
        = "bOrgCyfvw/s8C6q8E3vsSg";    #password is: lollipops
    $main::objects[1]{"activeFd"} = NONE;
    $main::objects[1]{"flags"} |= $flags{"wizard"}{"value"};
    $main::playerIds{"god"} = 1;
}

sub purge {
    %args = @_;
    my ($count);
    my (%junk);
    if ( !&Purl::tests::isWizard( $args{actor} ) ) {
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "Sorry, that command is for wizards only."
        );
        return;
    }

    # First pass: find junk; flag it as such
    for ( $i = 0; ( $i <= $#main::objects ); $i++ ) {
        next if ( $i < 2 );

        # Objects 0 and 1 are indestructible
        print STDERR "Purging: scanned $i of $#objects\n"
            if ( !( $i % 100 ) );
        if ( $main::objects[$i]{"type"} eq "" ) {
            $junk{$i} = 1;
            $main::objects[$i]{"type"} = NONE;
            $count++;
        }
    }

# Second pass: remove from inventories, destinations, etc. in an efficient way
    for ( $i = 0; ( $i <= $#objects ); $i++ ) {
        next if ( $junk{$i} );
        print STDERR "Purging: cleaned $i of $#objects\n"
            if ( !( $i % 100 ) );
        $main::objects[$i]{"owner"} = 1
            if ( $junk{ $main::objects[$i]{"owner"} } );    # Give to wizard
        $main::objects[$i]{"action"} = 0
            if ( $junk{ $main::objects[$i]{"action"} } );    # Unlink exit
        my (@list) = split( /,/, $main::objects[$i]{"contents"} );
        my (@nlist);
        for $l (@list) {
            next if ( $junk{$l} );
            push @nlist, $l;
        }
        $main::objects[$i]{"contents"} = join( ",", @nlist );
    }
    Purl::comm::sendTextToPlayer(
        target => $args{actor},
        text   => "$count broken objects recycled."
    );
}

sub dump {
    %args = @_;
    my $tempDB = config("dbfile") . ".tmp";
    my $dbFile = config("dbfile");
    Purl::comm::sendTextToPlayer(
        target => $args{actor},
        text   => "Dumping the database..."
        )
        if ( $args{actor} != NONE );
    if ( !CORE::open( OUT, ">$tempDB" ) ) {
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "Unable to write to $tempDB\n"
            )
            if ( $args{actor} != NONE );
        return;
    }
    my ($i);
    my ($now) = time;
    print OUT "$Version\n";
    for ( $i = 0; ( $i <= $#main::objects ); $i++ ) {

        # Don't save recycled objects
        next if ( $main::objects[$i]{"type"} == NONE );
        print OUT $i, "\n";

        # Now regular data
        my ( $attribute, $value );
        foreach $attribute ( keys %{ $main::objects[$i] } ) {

# Important: filter out any connection  dependent attributes here if you don't
# want them dumped and restored.
            next
                if ( $attribute eq "activeFd" )
                ;    # Connection dependent. Don't save it.
            next
                if ( $attribute eq "lastPing" )
                ;    # Connection dependent. Don't save it.
            next
                if ( $attribute eq "brain" )
                ;    # Do not attempt to write out the brain
            next if ( $attribute eq "id" );    # Already written out.
            $value = $main::objects[$i]{$attribute};
            $value =~ s/\\n/\\\\n/g;
            $value =~ s/\r\n/\\n/g;
            $value =~ s/\n/\\n/g;

            # Trim out null values at save time.
            print OUT $attribute, " ", $value, "\n" if ( $value ne "" );
        }
        print OUT "<END>\n";
    }
    if ( !close(OUT) ) {
        &wall( 1, "Warning: couldn't complete save to $tempDB!" );

        # Don't try again right away
        $lastdump = $now;
        return;
    }
    unlink($dbFile);
    rename "$tempDB", $dbFile;
    Purl::comm::sendTextToPlayer(
        target => $args{actor},
        text   => "Dump complete."
        )
        if ( $args{actor} != NONE );
    $main::lastdump = $now;
}

sub boot {
    %args = @_;
    if ( substr( $args{text}, 0, 1 ) ne "#" ) {
        my ($n);
        $n = $args{text};
        $n =~ tr/A-Z/a-z/;
        if ( !exists( $main::playerIds{$n} ) ) {
            Purl::comm::sendTextToPlayer(
                target => $args{actor},
                text   => "There is no such player."
            );
            return;
        }
        $id = $main::playerIds{$n};
    }
    else {
        $id = substr( $args{text}, 1 );
    }
    if ( $main::objects[$id]{"type"} != $main::player ) {
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "That is not a valid player."
        );
        return;
    }
    if ( $main::objects[$id]{"activeFd"} == NONE ) {
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "That player is not logged in."
        );
        return;
    }
    if ( $id == 1 ) {
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "Player #1 cannot be booted."
        );
        return;
    }
    Purl::Network::closePlayerID($id);
    Purl::comm::sendTextToPlayer( target => $args{actor}, text => "Booted." );
}

sub cmd_config {
    %args = @_;

    if ( $args{switch} eq "commands" ) {

# print "DEBUG - cmd_commands - me=$args{actor}, text=$args{text}, arg2=$arg2\n";
        $commandList = Purl::Commands::commandList;
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "Command List:\n$commandList\n\n"
        );
    }
    elsif ( $args{switch} eq "list" ) {
        my $return = config( action => list );
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "$args{text} : $return\n"
        );
    }
    elsif ( $args{switch} eq "set" ) {
        my ( $target, $value ) = split( /=/, $args{text}, 2 );

        my $return = config(
            action => "set",
            target => $target,
            value  => $value
        );    
        Purl::comm::sendTextToPlayer(
            target => $args{actor},
            text   => "$args{text} : $return\n"
        );
    }
    else {
        if ( $args{text} ) {
            my $return = config( lc( $args{text} ) );
            if ( $return == -1 ) {

                # No switch.
                Purl::comm::sendTextToPlayer(
                    target => $args{actor},
                    text   => "No such configuration attribute.\n"
                );
                return;
            }
            else {

                # No switch.
                Purl::comm::sendTextToPlayer(
                    target => $args{actor},
                    text   => "$args{text} : $return\n"
                );
            }
        }
        else {
            Purl::comm::sendTextToPlayer(
                target => $args{actor},
                text   =>
                    "USAGE: \@config <attribute>\n\n       \@config/list\n       \@config/commands\n"
            );

        }
    }
}

1;
